home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / oobr / br-env.el < prev    next >
Encoding:
Text File  |  1995-08-29  |  30.8 KB  |  865 lines
  1. ;;!emacs
  2. ;;
  3. ;; FILE:         br-env.el
  4. ;; SUMMARY:      OO-Browser Environment support functions.
  5. ;; USAGE:        GNU Emacs Lisp Library
  6. ;; KEYWORDS:     oop, tools
  7. ;;
  8. ;; AUTHOR:       Bob Weiner
  9. ;; ORG:          Motorola Inc.
  10. ;;
  11. ;; ORIG-DATE:     8-Jun-90
  12. ;; LAST-MOD:     26-Aug-95 at 14:22:08 by Bob Weiner
  13. ;;
  14. ;; Copyright (C) 1989-1995  Free Software Foundation, Inc.
  15. ;; See the file BR-COPY for license information.
  16. ;;
  17. ;; This file is part of the OO-Browser.
  18.  
  19. ;;; ************************************************************************
  20. ;;; Other required Elisp libraries
  21. ;;; ************************************************************************
  22.  
  23. (require 'hasht)
  24.  
  25. ;;; ************************************************************************
  26. ;;; Public variables
  27. ;;; ************************************************************************
  28.  
  29. (defvar br-env-default-file "OOBR"
  30.   "File name for OO-Browser environment storage.")
  31.  
  32. ;;; ************************************************************************
  33. ;;; Public functions
  34. ;;; ************************************************************************
  35.  
  36. (if (fboundp 'file-relative-name)
  37.     nil
  38.   ;; For V18 Emacs
  39.   (defun file-relative-name (filename &optional directory)
  40.     "Convert FILENAME to be relative to DIRECTORY (default: default-directory)."
  41.     (setq filename (expand-file-name filename)
  42.       directory (file-name-as-directory (if directory
  43.                         (expand-file-name directory)
  44.                           default-directory)))
  45.     (while directory
  46.       (let ((up (file-name-directory (directory-file-name directory))))
  47.     (cond ((and (string-equal directory up)
  48.             (file-name-absolute-p directory))
  49.            ;; "/"
  50.            (setq directory nil))
  51.           ((string-match (concat "\\`" (regexp-quote directory))
  52.                  filename)
  53.            (setq filename (substring filename (match-end 0)))
  54.            (setq directory nil))
  55.           (t
  56.            ;; go up one level
  57.            (setq directory up)))))
  58.     filename))
  59.  
  60. ;;;###autoload
  61. (defun br-env-browse (env-file)
  62.   "Invoke the OO-Browser on ENV-FILE."
  63.   (interactive "fBrowse OO-Browser environment: ")
  64.   (if (not (stringp env-file))
  65.       (error "(br-env-browse): Invalid env file: '%s'" env-file))
  66.   (if (string-match "-FTR$" env-file)
  67.       (setq env-file (substring env-file 0 (match-beginning 0))))
  68.   (if (not (and (file-exists-p env-file)
  69.         (file-readable-p env-file)))
  70.       (error "(br-env-browse): Env file '%s' is unreadable." env-file))
  71.   (let ((lang-string))
  72.     (save-excursion
  73.       (set-buffer (find-file-noselect env-file))
  74.       (save-restriction
  75.     (widen)
  76.     (goto-char (point-min))
  77.     (if (search-forward "br-lang-prefix" nil t)
  78.         (progn (forward-line 1)
  79.            ;; Eval removes quote from in front of lang-string value
  80.            ;; which is read from the Env file.
  81.            (setq lang-string (eval (read (current-buffer))))))))
  82.     (if lang-string
  83.     (funcall (intern-soft (concat lang-string "browse"))
  84.          env-file)
  85.       (error "(br-env-browse): Invalid env file: '%s'" env-file))))
  86.  
  87. (defun br-env-build (&optional env-file background-flag)
  88.   "Build Environment from spec given by optional ENV-FILE or 'br-env-file'.
  89. If optional 2nd argument BACKGROUND-FLAG is non-nil, build the environment
  90. using a background process."
  91.   (interactive
  92.    (let ((env-file (br-env-default-file)))
  93.      (list (read-file-name
  94.         (format "Build Environment (default \"%s\"): "
  95.             (br-relative-path env-file))
  96.         (file-name-directory env-file)
  97.         env-file t)
  98.        (y-or-n-p "Use a background process for building? "))))
  99.   (if (or (not (stringp env-file)) (equal env-file ""))
  100.       (setq env-file br-env-file))
  101.   (setq env-file (expand-file-name env-file))
  102.   (or (not (file-exists-p env-file)) (file-readable-p env-file)
  103.       (error (format "Non-readable Environment file, %s" env-file)))
  104.   (or (file-writable-p env-file)
  105.       (error (format "Non-writable Environment file, %s" env-file)))
  106.   (if background-flag
  107.       (progn (setenv "OOBR_DIR" br-directory)
  108.          (setenv "OOBR_ENV" env-file)
  109.          (compile (format
  110.                "make -f %s %s oobr-env"
  111.                (expand-file-name "Makefile" br-directory)
  112.                (if (and (boundp 'invocation-directory)
  113.                 (boundp 'invocation-name)
  114.                 (stringp invocation-directory)
  115.                 (stringp invocation-name)
  116.                 (file-directory-p invocation-directory)
  117.                 (file-name-absolute-p invocation-directory))
  118.                (concat "EMACS="
  119.                    (expand-file-name
  120.                     invocation-name invocation-directory))
  121.              ""))))
  122.     (br-env-load env-file nil t)
  123.     ;; Detach unneeded data so can be garbage collected.
  124.     (br-env-create-alists)
  125.     (br-env-create-htables)
  126.     (if (and (boundp 'br-feature-tags-file) (stringp br-feature-tags-file))
  127.     (progn
  128.       (if (not (file-writable-p br-feature-tags-file))
  129.           (error
  130.            "(br-env-build): %s is not writable" br-feature-tags-file))
  131.       (set-buffer (find-file-noselect br-feature-tags-file))
  132.       (setq buffer-read-only nil)
  133.       (erase-buffer)
  134.       (set-buffer-modified-p nil)))
  135.     (br-build-sys-htable)
  136.     (br-build-lib-htable)
  137.     (setq br-env-spec nil)
  138.     (br-env-save)
  139.     ;; Detach unneeded data so can be garbage collected.
  140.     (br-env-create-alists)
  141.     (br-env-load env-file nil t)))
  142.  
  143. (defun br-env-rebuild ()
  144.   "Rescan System and Library sources associated with the current Environment."
  145.   (interactive)
  146.   (if (and (interactive-p)
  147.        (not (y-or-n-p "Rebuild current Environment? ")))
  148.       nil
  149.     (let ((background-flag
  150.        (and (interactive-p)
  151.         (y-or-n-p "Use a background process for building? "))))
  152.       (br-env-build nil background-flag)
  153.       (or background-flag (br-top-classes t)))))
  154.  
  155. (defun br-env-create (&optional env-file lang-prefix)
  156.   "Create and save the specification of a new OO-Browser Environment.
  157. Interactively prompt for the Environment file name or use optional ENV-FILE.
  158. Interactively prompt for the Environment language to use or use optional
  159. LANG-PREFIX as language indicator.  Return the name of the Envir spec file
  160. created.  Do not build the Environment.  Use 'br-env-build' to construct an
  161. Environment from its specification."
  162.   (interactive)
  163.   (if env-file
  164.       (read-string
  165.     (format "Please specify the \"%s\" Environment (Hit RTN to begin)."
  166.         (file-name-nondirectory env-file)))
  167.     (setq env-file (br-env-default-file)
  168.       env-file (read-file-name
  169.             (format "Create Env spec file (default \"%s\"): "
  170.                 (br-relative-path env-file))
  171.             (file-name-directory env-file)
  172.             env-file nil)))
  173.   (setq env-file (expand-file-name env-file))
  174.   ;; Display Env spec if previous one existed
  175.   (and (equal env-file br-env-file) (file-readable-p env-file) (br-env-stats))
  176.   (let ((prompt "System search dir #%d (RTN to end): ")
  177.     (br-env-spec t)
  178.     br-sys-search-dirs br-lib-search-dirs
  179.     br-lang-prefix
  180.     br-children-htable
  181.     br-sys-paths-htable
  182.     br-sys-parents-htable
  183.     br-lib-paths-htable
  184.     br-lib-parents-htable
  185.     br-paths-htable
  186.     br-parents-htable)
  187.     (br-env-create-htables)
  188.     (setq br-lang-prefix (or lang-prefix (br-env-select-lang))
  189.       br-sys-search-dirs (br-env-get-dirs prompt)
  190.       prompt "Library search dir #%d (RTN to end): "
  191.       br-lib-search-dirs (br-env-get-dirs prompt))
  192.     ;; Now since user has not aborted, set real variables
  193.     (setq br-env-spec t)
  194.     (br-env-save env-file)
  195.     ;; If re-specifying current Env, then also rebuild it.
  196.     (if (equal env-file br-env-file)
  197.     (if (br-in-browser)
  198.         ;; auto-build
  199.         (br-env-build)
  200.       ;; else prompt and build
  201.       (call-interactively 'br-env-build)))
  202.     env-file))
  203.  
  204. ;;;###autoload
  205. (defun br-env-load (&optional env-file prompt no-build)
  206.   "Load browser Environment or spec from optional ENV-FILE or 'br-env-file'.
  207. Non-nil PROMPT means prompt user before building tables.
  208. Non-nil NO-BUILD means skip build of Environment entirely.
  209. Return t if load is successful, else nil."
  210.   (interactive
  211.    (let ((env-file (br-env-default-file)))
  212.      (list (read-file-name
  213.         (format "Environment file to load (default \"%s\"): "
  214.             (br-relative-path env-file))
  215.         (file-name-directory env-file)
  216.         env-file t))))
  217.   (setq env-file (or (and (not (equal env-file "")) env-file)
  218.              (br-env-default-file))
  219.     env-file (expand-file-name env-file)
  220.     br-env-file env-file)
  221.   (let ((buf (get-file-buffer env-file)))
  222.     (and buf (kill-buffer buf)))
  223.   (let ((br-loaded))
  224.     (if (file-readable-p env-file)
  225.     (unwind-protect
  226.         (progn
  227.           (message "Loading Environment...")
  228.           (sit-for 1)
  229.           ;; Ensure spec and version values are nil for old
  230.           ;; Environment files that do not contain a setting for
  231.           ;; these variables.
  232.           (setq br-env-spec nil br-env-version nil)
  233.           (load-file env-file)
  234.  
  235.           (if br-env-spec
  236.           nil
  237.         (setq br-children-htable (hash-make br-children-alist)
  238.               br-sys-paths-htable (hash-make br-sys-paths-alist)
  239.               br-lib-paths-htable (hash-make br-lib-paths-alist)
  240.               br-sys-parents-htable
  241.               (hash-make br-sys-parents-alist)
  242.               br-lib-parents-htable
  243.               (hash-make br-lib-parents-alist)
  244.               )
  245.         (br-env-set-htables))
  246.  
  247.           ;; Prevent rebuilding of Environment
  248.           (setq br-lib-prev-search-dirs br-lib-search-dirs
  249.             br-sys-prev-search-dirs br-sys-search-dirs)
  250.           (setq br-loaded t)
  251.           (message "Loading Environment...Done")
  252.           (cond
  253.            ((and br-env-spec (not no-build))
  254.         (setq br-loaded
  255.               (br-env-cond-build
  256.                env-file
  257.                (if prompt "Build Environment from spec in file, \"%s\"? "))))
  258.            ;; If Environment was built with a version of the OO-Browser
  259.            ;; which did not add a version number to each Environment,
  260.            ;; then it may use an obsolete format.  Offer to rebuild it.
  261.            ((and (not no-build) (null br-env-version)
  262.              (br-member br-lang-prefix '("c++-" "objc-" "eif-")))
  263.         (br-env-stats)
  264.         (br-env-cond-build
  265.          env-file
  266.          (if prompt
  267.              "Environment file format is obsolete, rebuild it? ")))))
  268.       nil)
  269.       (if (file-exists-p env-file)
  270.       (progn (beep)
  271.          (message "No read rights for Envir file, \"%s\"" env-file)
  272.          (sit-for 4))
  273.     (message "\"%s\", no such file." env-file)
  274.     (sit-for 2)
  275.     (setq br-loaded (br-env-load
  276.              (br-env-create env-file br-lang-prefix) t))))
  277.     br-loaded))
  278.  
  279. (defun br-env-save (&optional save-file)
  280.   "Save changed Environment to file given by optional SAVE-FILE or 'br-env-file'."
  281.   (interactive
  282.    (let ((env-file (br-env-default-file)))
  283.      (list (read-file-name
  284.         (format "Save Environment to (default \"%s\"): "
  285.             (br-relative-path env-file))
  286.         (file-name-directory env-file)
  287.         env-file nil))))
  288.   (if (and (stringp save-file)
  289.        (not (equal save-file br-env-file))
  290.        (stringp br-feature-tags-file)
  291.        (file-exists-p br-feature-tags-file))
  292.       ;; Copy feature tags file to new file name.
  293.       (copy-file br-feature-tags-file (br-feature-tags-file-name save-file)
  294.          t t))
  295.   (if (or (not (stringp save-file)) (equal save-file ""))
  296.       (setq save-file br-env-file))
  297.   (setq save-file (expand-file-name save-file))
  298.   (or (file-writable-p save-file)
  299.       (error (format "Non-writable Environment file, \"%s\""
  300.              save-file)))
  301.   (let ((buf (get-file-buffer save-file)))
  302.     (and buf (kill-buffer buf)))
  303.   (let ((dir (or (file-name-directory save-file)
  304.          default-directory)))
  305.     (or (file-writable-p dir)
  306.     (error (format "Non-writable Environment directory, \"%s\"" dir))))
  307.   (save-window-excursion
  308.     (let ((standard-output
  309.         (set-buffer (funcall br-find-file-noselect-function
  310.                  save-file)))
  311.       (buffer-read-only)
  312.       br-sym)
  313.       (erase-buffer)
  314.       (princ "\n(setq\nbr-env-version")
  315.       (print br-version)
  316.       (br-env-save-mult-vars (cons (car br-env-mult-vars) nil))
  317.       (mapcar (function
  318.         (lambda (nm)
  319.           (setq br-sym (intern-soft (concat "br-" nm)))
  320.           (let ((nm-mid (string-match "-htable$" nm)))
  321.             (if nm-mid
  322.             (progn (princ "\nbr-") (princ (substring nm 0 nm-mid))
  323.                    (princ "-alist\n'")
  324.                    (hash-prin1 (symbol-value br-sym)))
  325.               (princ "\n") (princ br-sym) (princ "\n'")
  326.               (prin1 (symbol-value br-sym)) (princ "\n")))))
  327.           br-env-single-vars)
  328.       (br-env-save-mult-vars (cdr br-env-mult-vars))
  329.       (princ ")\n")
  330.       (save-buffer)
  331.       (kill-buffer standard-output))))
  332.  
  333. (defun br-env-stats (&optional arg)
  334.   "Display summary for current Environment in viewer window.
  335. With optional prefix ARG, display class totals in minibuffer."
  336.   (interactive "P")
  337.   (let ((env-file (abbreviate-file-name br-env-file)))
  338.     (if arg
  339.     (message "Envir \"%s\": %s" env-file (br-env-totals))
  340.       (br-funcall-in-view-window
  341.        (concat br-buffer-prefix-info "Info")
  342.        (function
  343.     (lambda ()
  344.       (insert (format "Environment: \"%s\"" env-file))
  345.       (center-line)
  346.       (insert "\n\n")
  347.       (if (null br-env-spec)
  348.           (insert (format "Built by version %s of the OO-Browser.\n\n"
  349.                   (or br-env-version "earlier than 02.09.03"))))
  350.       (insert (br-env-totals) "\n\n")
  351.       (let ((undefined (br-undefined-classes)))
  352.         (if undefined
  353.         (insert (format "Undefined classes: %s\n\n" undefined))))
  354.       (mapcar
  355.        (function
  356.         (lambda (sys-lib)
  357.           (insert (format "Directories to search for %s classes:\n"
  358.                   (car sys-lib)))
  359.           (if (cdr sys-lib)
  360.           (progn (mapcar
  361.               (function
  362.                (lambda (dir)
  363.                  (or (equal dir "")
  364.                  (insert
  365.                   (format "\t%s\n"
  366.                       (abbreviate-file-name dir))))))
  367.                  (cdr sys-lib))
  368.              (insert "\n"))
  369.         (insert "\t<None>\n\n"))))
  370.        (list (cons "System" br-sys-search-dirs)
  371.          (cons "Library"  br-lib-search-dirs)))
  372.       (insert "Flag Settings:"
  373.           "\n\tEnvironment built from specification: "
  374.           (if br-env-spec "no" "yes")
  375.           "\n")
  376.       (set-buffer-modified-p nil)))))))
  377.  
  378. ;;; ************************************************************************
  379. ;;; Private functions
  380. ;;; ************************************************************************
  381.  
  382. (defun br-env-add-ref-classes (&optional htable-type)
  383.   "Add classes to Environment which are referenced in it but not defined.
  384. With optional HTABLE-TYPE, affect only that part of the Environment.
  385. HTABLE-TYPE may be \"sys\"or \"lib\".  By default, add to both Library and
  386. whole Environment tables."
  387.   ;;
  388.   ;; This function must NOT call any 'get-htable' type functions or it will
  389.   ;; cause an infinite loop.
  390.   (let ((classes (br-all-classes
  391.           (symbol-value
  392.            (intern-soft (concat "br-" htable-type
  393.                     (if htable-type "-")
  394.                     "paths-htable")))))
  395.     (pars (br-env-all-parents
  396.            (symbol-value
  397.         (intern-soft (concat "br-" htable-type
  398.                      (if htable-type "-")
  399.                      "parents-htable")))))
  400.     (class))
  401.     (while pars
  402.       (setq class (car pars)
  403.         pars (cdr pars))
  404.       (if (or (null class) (br-member class classes))
  405.       nil
  406.     (setq classes (cons class classes))
  407.     (if (null htable-type) (setq htable-type "lib"))
  408.     (br-env-add-to-htables class (concat htable-type "-parents"))
  409.     (br-add-to-paths-htable
  410.      class br-null-path
  411.      (br-get-htable (concat htable-type "-paths")))))))
  412.  
  413. (defun br-env-add-to-htables (class parents)
  414.   "Add CLASS to hash tables referenced by PARENTS name.
  415. PARENTS may be \"parents\", \"sys-parents\", or \"lib-parents\"."
  416.   (if (null class)
  417.       nil
  418.     (setq parents
  419.       (symbol-value (intern-soft (concat "br-" parents "-htable"))))
  420.     (if parents (hash-add nil class parents))))
  421.  
  422. (defun br-env-all-parents (&optional htable-type)
  423.   "Return list of all parent names in Environment or optional HTABLE-TYPE.
  424. HTABLE-TYPE may be \"sys\" or \"lib\". or an actual hash table."
  425.   (apply 'append
  426.      (hash-map 'car
  427.            (cond ((and (stringp htable-type)
  428.                    (not (string-equal htable-type "")))
  429.               (br-get-htable (concat htable-type "-parents")))
  430.              ((hashp htable-type) htable-type)
  431.              (t (br-get-parents-htable))))))
  432.  
  433. (defun br-env-batch-build ()
  434.   "Build Environments from specifications while running Emacs in batch mode.
  435. Invoke via a shell command line of the following form:
  436. emacs -batch -l <BR-DIR>/br-start.el <OO-Browser Env Spec File> ... <Spec File> -f br-env-batch-build"
  437.   (br-init-autoloads)
  438.   (if (or (not (boundp 'br-directory)) (null br-directory)
  439.       (not (file-exists-p br-directory)))
  440.       (error "br-env-batch-build: Set 'br-directory' properly before use.")
  441.     (let ((spec-file)
  442.       (files (delq nil (mapcar 'buffer-file-name (buffer-list)))))
  443.       (while (setq spec-file (car files))
  444.     (setq files (cdr files))
  445.     (load spec-file)
  446.     (or (featurep (intern-soft (concat br-lang-prefix "browse")))
  447.         (featurep (intern-soft (concat br-lang-prefix "brows")))
  448.         (load (expand-file-name
  449.            (concat br-lang-prefix "browse") br-directory)
  450.           t)
  451.         (load (expand-file-name
  452.            (concat br-lang-prefix "brows") br-directory)))
  453.     (funcall (intern (concat br-lang-prefix "browse-setup")))
  454.     (kill-buffer nil)
  455.     (br-env-build spec-file)))))
  456.  
  457. ;;; The following function is called by the compilation sentinel whenever a
  458. ;;; compilation finishes under versions of Emacs 19.  (If you use Emacs 18,
  459. ;;; you would have to edit compilation-sentinel to call the function stored
  460. ;;; in 'compilation-finish-function' as Emacs 19, compile.el does.
  461. ;;;
  462. ;;; If there already is a compilation-finish-function, save it and use it
  463. ;;; when not in a batch environment build.
  464. (setq compilation-original-finish-function
  465.       (and (boundp 'compilation-finish-function)
  466.        (not (eq compilation-finish-function 'br-env-batch-build-browse))
  467.        compilation-finish-function)
  468.       compilation-finish-function 'br-env-batch-build-browse)
  469.  
  470. (defun br-env-batch-build-browse (&rest args)
  471.   ;; This is only called when we are in the compilation buffer already.
  472.   (cond ((not (string-match "oobr-env" compile-command))
  473.      ;; Some other type of build.
  474.      (if compilation-original-finish-function
  475.          (apply compilation-original-finish-function args)))
  476.     ((not (and (stringp mode-line-process)
  477.            (string-match "OK" mode-line-process)))
  478.      ;; Build failed.
  479.      nil)
  480.     (t ;; Environment build was successful.
  481.      (beep)
  482.      (let* ((env-file (getenv "OOBR_ENV"))
  483.         (prompt
  484.          (format
  485.           "(OO-Browser): Environment \"%s\" is built; browse it now? "
  486.           (file-name-nondirectory env-file))))
  487.        (if (y-or-n-p prompt)
  488.            (br-env-browse env-file))))))
  489.  
  490. (defun br-env-cond-build (env-file prompt)
  491. "Build current Environment from its specification and save it in ENV-FILE.
  492. Non-nil PROMPT is used to prompt user before building Environment.  Return t
  493. iff current Environment gets built from spec."
  494.   (let ((dir (or (file-name-directory env-file)
  495.          default-directory)))
  496.     (if (not (file-writable-p dir))
  497.     (progn (beep)
  498.            (message "Unwritable Environment directory, \"%s\"" dir)
  499.            (sit-for 4) nil)
  500.       (if (or (not prompt)
  501.           (y-or-n-p (format prompt env-file)))
  502.       (progn (br-env-build env-file) t)))))
  503.  
  504. (defun br-env-copy (to-br)
  505.   "Copy 'br-' Environment to or from 'br-lang-prefix' language variables.
  506. If TO-BR is non-nil, copy from language-specific variables to browser
  507. variables.  Otherwise, do copy in the reverse direction."
  508.   (let* ((var1) (var2)
  509.      (copy-func
  510.       (if to-br (function (lambda () (set var1 (symbol-value var2))))
  511.         (function (lambda () (set var2 (symbol-value var1)))))))
  512.     (mapcar (function
  513.           (lambda (nm)
  514.            (setq var1 (intern (concat "br-" nm))
  515.              var2 (intern (concat br-lang-prefix nm)))
  516.            (funcall copy-func)))
  517.         (append
  518.           '("env-file" "env-version" "lib-search-dirs"
  519.         "lib-prev-search-dirs" "lib-parents-htable"
  520.         "lib-paths-htable" "sys-search-dirs"
  521.         "sys-prev-search-dirs" "sys-parents-htable"
  522.         "sys-paths-htable" "paths-htable" "parents-htable")
  523.           br-env-single-vars))))
  524.  
  525. (defun br-env-create-alists ()
  526.   "Create all empty Environment association lists."
  527.   (setq br-children-alist    nil
  528.     br-sys-paths-alist   nil  br-lib-paths-alist nil
  529.     br-sys-parents-alist nil  br-lib-parents-alist nil
  530.     br-paths-alist       nil  br-parents-alist nil))
  531.  
  532. (defun br-env-create-htables ()
  533.   "Create all empty Environment hash tables."
  534.   (setq br-children-htable (hash-make 0)
  535.     br-sys-paths-htable (hash-make 0)
  536.     br-sys-parents-htable (hash-make 0)
  537.     br-lib-paths-htable (hash-make 0)
  538.     br-lib-parents-htable (hash-make 0)
  539.     br-paths-htable (hash-make 0)
  540.     br-parents-htable (hash-make 0)))
  541.  
  542. (defun br-env-default-file (&optional directory)
  543.   "Search up current or optional DIRECTORY tree for an OO-Browser environment file.
  544. Return file name found, the value of 'br-env-file' if non-nil, or else the
  545. value of 'br-env-default-file'.  All return values are expanded to absolute
  546. paths before being returned."
  547.   (let ((path directory)
  548.     (oobr-file))
  549.     (while (and (stringp path)
  550.         (setq path (file-name-directory path))
  551.         (setq path (directory-file-name path))
  552.         ;; Not at root directory
  553.         (not (string-match ":?/\\'" path))
  554.         ;; No environment file
  555.         (not (file-exists-p
  556.               (setq oobr-file (expand-file-name
  557.                        br-env-default-file path)))))
  558.       (setq oobr-file nil))
  559.     (expand-file-name (or oobr-file br-env-file br-env-default-file))))
  560.  
  561. (defun br-env-file-sym-val (symbol-name)
  562.   "Given a SYMBOL-NAME, a string, find its value in the current Environment file.
  563. Assume the Environment file to use is attached to the current buffer.
  564. Only search for the SYMBOL-NAME from the current point in the buffer.
  565. Return cons whose car is t iff SYMBOL-NAME was found and then whose cdr is the
  566. non-quoted value found."
  567.   (set-buffer (funcall br-find-file-noselect-function br-env-file))
  568.   (save-excursion
  569.     (if (search-forward symbol-name nil t)
  570.     (let ((standard-input (current-buffer)))
  571.       (cons t (eval (read)))))))
  572.  
  573. (defun br-env-force-load (env-file default-file)
  574.   "Force the loading of a complete Environment, initially given by ENV-FILE.
  575. If an Environment specification is selected, it must be built before this
  576. function will exit.  If ENV-FILE is not a string, the function will prompt
  577. for an Environment to load.  DEFAULT-FILE is the default file to use when an
  578. empty value is given at the Environment file prompt."
  579.   ;; Loop until an Environment is loaded or Envir spec is loaded and
  580.   ;; then built, or command is aborted.
  581.   (while (not (br-env-load
  582.            (if (stringp env-file)
  583.            env-file
  584.          (or (stringp default-file)
  585.              (setq default-file (br-env-default-file)))
  586.          (setq env-file
  587.                (read-file-name
  588.             (format
  589.              "OO-Browser Environment file (default \"%s\"): "
  590.              (br-relative-path default-file))
  591.             nil
  592.             default-file nil)))
  593.            'prompt))
  594.     (setq env-file nil))
  595.   (and (stringp env-file) (setq br-env-file (expand-file-name env-file))))
  596.  
  597. (defun br-env-get-dirs (prompt)
  598.   "PROMPT for and return list of directory names.
  599. PROMPT must contain a %d somewhere in it, so dir # may be inserted."
  600.   (let ((dir) (dirs) (num 1) (default ""))
  601.     (while (not (string-equal "" (setq dir (read-file-name
  602.                        (format prompt num) default "" t))))
  603.       (if (file-directory-p dir)
  604.       (setq dirs (cons dir dirs)
  605.         num (1+ num)
  606.         default "")
  607.     (beep)
  608.     (setq default dir)))
  609.     (nreverse dirs)))
  610.  
  611. (defun br-env-init (env-file same-lang same-env)
  612.   "Load or build ENV-FILE if non-nil.
  613. Otherwise, use 'br-env-file' if non-nil or if not, interactively prompt for
  614. Environment name.  SAME-LANG should be non-nil if invoking the OO-Browser on
  615. the same language again.  SAME-ENV should be non-nil if invoking the
  616. OO-Browser on the same Environment again.  br-sys/lib-search-dirs variables
  617. should be set before this function is called."
  618.   (cond 
  619.  
  620.     ;; Specific environment requested
  621.     (env-file
  622.       ;; Create or load spec and load or build Environment
  623.       (setq env-file (br-env-force-load env-file br-env-file)))
  624.     
  625.     ;; First invocation on this lang
  626.     ((and (null br-sys-search-dirs) (null br-lib-search-dirs))
  627.      ;; Create or load spec and load or build Environment
  628.      (setq env-file
  629.        (br-env-force-load (or br-env-file (br-env-create)) br-env-file)))
  630.     
  631.     ;; Non-first invocation, search paths have been set, possibly default Env
  632.     (t
  633.       (cond
  634.     ;; Continue browsing an Environment
  635.     (same-env nil)
  636.     (same-lang
  637.       ;; But search paths have changed, so rebuild Env
  638.       (progn (or (eq br-sys-search-dirs br-sys-prev-search-dirs)
  639.              (br-build-sys-htable))
  640.          (or (eq br-lib-search-dirs br-lib-prev-search-dirs)
  641.              (br-build-lib-htable))))
  642.     ;; Request to browse a different language Env
  643.     (t
  644.       (setq env-file (br-env-force-load
  645.                (or br-env-file (br-env-create)) br-env-file)))
  646.     )))
  647.   env-file)
  648.  
  649. (defun *br-env-internal-structures* ()
  650.   "Display values of internal data structures in viewer buffer."
  651.   (interactive)
  652.   (br-funcall-in-view-window
  653.    (concat br-buffer-prefix-info "Info")
  654.    (function
  655.     (lambda ()
  656.       (let ((standard-output (current-buffer)))
  657.     (mapcar
  658.      (function
  659.       (lambda (sym)
  660.         (mapcar
  661.          (function (lambda (obj)
  662.              (princ obj)))
  663.          (list "!!! " (symbol-name sym) " !!!\n\n" 
  664.            (symbol-value sym) "\n \n"))
  665.         ))
  666.      '(br-children-htable
  667.        br-parents-htable
  668.        br-paths-htable
  669.        br-sys-search-dirs
  670.        br-sys-paths-htable
  671.        br-sys-parents-htable
  672.        br-lib-search-dirs
  673.        br-lib-paths-htable
  674.        br-lib-parents-htable
  675.        br-lang-prefix
  676.        br-env-spec)))))))
  677.  
  678. (defun br-env-lang-dialog-box (dialog-box)
  679.   "Prompt user with DIALOG-BOX and return selected value.
  680. Assumes caller has checked that 'dialog-box' function exists."
  681.   (let ((echo-keystrokes 0)
  682.     event-obj
  683.     event)     
  684.     ;; Add a cancel button to dialog box.
  685.     (setq dialog-box (append dialog-box (list nil '["Cancel" abort t])))
  686.     (popup-dialog-box dialog-box)
  687.     (catch 'br-env-done
  688.       (while t
  689.     (setq event (next-command-event event)
  690.           event-obj (event-object event))
  691.     (cond ((and (menu-event-p event)
  692.             (memq event-obj '(abort menu-no-selection-hook)))
  693.            (signal 'quit nil))
  694.           ((button-release-event-p event) ;; don't beep twice
  695.            nil)
  696.           ((menu-event-p event)
  697.            (throw 'br-env-done (eval event-obj)))
  698.           (t
  699.            (beep)
  700.            (message "Please answer the dialog box.")))))))
  701.  
  702. (defun br-env-lang-var (lang-prefix)
  703.   "Create language-specific Environment variables for LANG-PREFIX."
  704.   (eval (list 'defvar (intern (concat lang-prefix "env-version"))
  705.           nil
  706.           "Version of the OO-Browser used to build the current Environment or nil."))
  707.   (eval (list 'defvar (intern (concat lang-prefix "env-file"))
  708.           br-env-default-file
  709.           "*File in which to save Environment.")))
  710.  
  711. (defun br-env-load-matching-htables (changed-types-list)
  712.   (let ((still-changed-types))
  713.     (if (file-readable-p br-env-file)
  714.     (unwind-protect
  715.         (progn
  716.           (let ((buf (get-file-buffer br-env-file)))
  717.         (and buf (kill-buffer buf)))
  718.           (set-buffer (funcall br-find-file-noselect-function br-env-file))
  719.           (goto-char (point-min))
  720.           (mapcar
  721.         (function
  722.           (lambda (type)
  723.             (let* ((search-dirs (concat "br-" type "-search-dirs"))
  724.                (prev-dirs (concat "br-" type "-prev-search-dirs"))
  725.                (paths (concat "br-" type "-paths-htable"))
  726.                (parents (concat "br-" type "-parents-htable"))
  727.                (dirs-val (cdr (br-env-file-sym-val search-dirs))))
  728.               (if (equal dirs-val (symbol-value (intern search-dirs)))
  729.               (and (br-member type changed-types-list)
  730.                    (progn (set (intern paths)
  731.                        (cdr (br-env-file-sym-val paths)))
  732.                       (set (intern parents)
  733.                        (cdr (br-env-file-sym-val parents)))
  734.                       (set (intern prev-dirs)
  735.                        (symbol-value
  736.                          (intern search-dirs)))))
  737.             (setq still-changed-types
  738.                   (cons type still-changed-types)))))) 
  739.         '("sys" "lib"))
  740.           )
  741.       nil))
  742.     (nreverse still-changed-types)))
  743.  
  744. (defun br-env-save-mult-vars (mult-vars)
  745.   (let ((br-sym))
  746.     (mapcar
  747.       (function
  748.     (lambda (suffix)
  749.       (mapcar
  750.         (function
  751.           (lambda (type-str)
  752.         (setq br-sym (intern-soft
  753.                    (concat "br-" type-str suffix)))
  754.         (if (and br-sym (boundp br-sym))
  755.             (let* ((nm (symbol-name br-sym))
  756.                (nm-mid (string-match "-htable$" nm)))
  757.               (if nm-mid
  758.               (progn (princ "\n") (princ (substring nm 0 nm-mid))
  759.                  (princ "-alist\n'")
  760.                  (hash-prin1 (symbol-value br-sym)))
  761.             (princ "\n") (princ br-sym) (princ "\n'")
  762.             (prin1 (symbol-value br-sym))
  763.             (princ "\n"))))))
  764.         '("sys-" "lib-"))))
  765.       mult-vars)))
  766.  
  767. (defun br-env-set-htables ()
  768.   (br-env-add-ref-classes "lib")
  769.   (br-env-add-ref-classes "sys")
  770.   ;; Make System entries override Library entries which they duplicate, since
  771.   ;; this is generally more desireable than merging the two.  Don't do this
  772.   ;; for the paths-htable, however, since the value is the union of both
  773.   ;; values.
  774.   (setq br-paths-htable (hash-merge br-sys-paths-htable br-lib-paths-htable))
  775.   (let ((hash-merge-values-function (function (lambda (val1 val2) val1))))
  776.     (setq br-parents-htable (hash-merge br-sys-parents-htable
  777.                     br-lib-parents-htable))))
  778.  
  779. (defun br-env-select-lang ()
  780.   "Interactively select and return value for 'br-lang-prefix'."
  781.   (let ((n 0) (nlangs (length br-env-lang-avector))
  782.     (lang-prompt)
  783.     ;; Use dialog box if last user event involved the mouse.
  784.     (use-dialog-box (and (fboundp 'popup-dialog-box)
  785.                  (fboundp 'button-press-event-p)
  786.                  (or (button-press-event-p last-command-event)
  787.                  (button-release-event-p last-command-event)
  788.                  (menu-event-p last-command-event)))))
  789.     ;; Create a prompt numbering each OO-Browser language available.
  790.     (setq lang-prompt
  791.       (if use-dialog-box
  792.           (mapcar
  793.            (function (lambda (lang)
  794.                (setq n (1+ n))
  795.                (vector lang (list 'identity n) 't)))
  796.            (mapcar 'car br-env-lang-avector))
  797.         (mapconcat
  798.          (function (lambda (lang)
  799.              (setq n (1+ n))
  800.              (format "%d\) %s" n lang)))
  801.          (mapcar 'car br-env-lang-avector)
  802.          "; ")))
  803.     ;; Prompt user.
  804.     (while (progn
  805.          (setq n (if use-dialog-box
  806.              (br-env-lang-dialog-box
  807.               (cons "Choose language to browse: " lang-prompt))
  808.                ;; Otherwise, prompt in the minibuffer.
  809.                (string-to-int
  810.             (read-string (concat "Choose: " lang-prompt ": ") ""))))
  811.          (or (< n 1) (> n nlangs)))
  812.       (beep))
  813.     (cdr (aref br-env-lang-avector (1- n)))))
  814.  
  815. (defun br-env-totals ()
  816.   "Return string of Environment class totals."
  817.   (let ((sys (length (br-all-classes "sys")))
  818.     (lib (length (br-all-classes "lib")))
  819.     (duplicates (car (br-all-classes nil t)))
  820.     count)
  821.     (format "%sTotal unique classes: %d; System: %d; Library: %d"
  822.         (if (null duplicates)
  823.         ""
  824.           (setq count (length duplicates))
  825.           (format "%d DUPLICATE CLASS%s TO CONSIDER ELIMINATING:\n\t%s\n\n"
  826.               count (if (= count 1) "" "ES") duplicates))
  827.         (+ sys lib) sys lib)))
  828.  
  829. ;;; ************************************************************************
  830. ;;; Internal variables
  831. ;;; ************************************************************************
  832.  
  833. (defvar br-env-version nil
  834.   "Version of the OO-Browser used to build the current Environment or nil.")
  835.  
  836. (defconst br-env-mult-vars
  837.   '("search-dirs" "paths-htable" "parents-htable")
  838.   "Descriptors of multiple copy variables saved as part of an Environment.")
  839. (defconst br-env-single-vars
  840.   '("lang-prefix" "env-spec" "children-htable")
  841.   "Descriptors of singular variables saved as part of an Environment.")
  842.  
  843. (defvar br-env-file nil
  844.   "Default file into which to save a class Environment.
  845. Value is language-specific.")
  846.  
  847. (defvar br-env-spec nil
  848.   "Non-nil value means Environment specification has been given but not yet built.
  849. Nil means current Environment has been built, though it may still require
  850. updating. Value is language-specific.")
  851.  
  852. (defvar br-env-lang-avector
  853.   '[("C++"     . "c++-")
  854.     ("Eiffel"  . "eif-")
  855.     ("Info"    . "info-")
  856.     ("Java"    . "java-")
  857.     ("Lisp"    . "clos-")
  858.     ("Obj-C"   . "objc-")
  859.     ("Smalltalk" . "smt-")]
  860.   "Association vector of (LANGUAGE-NAME . LANGUAGE-PREFIX-STRING) elements of OO-Browser languages.")
  861.  
  862. (mapcar 'br-env-lang-var (mapcar 'cdr br-env-lang-avector))
  863.  
  864. (provide 'br-env)
  865.